home *** CD-ROM | disk | FTP | other *** search
/ Acorn User: China / Acorn User China CD-ROM (UK) (Disc A) / Acorn User China CD-ROM (UK) (Disc A).bin / HENSA / MATHS / JACAL.ARC / jacal_sect < prev    next >
Encoding:
Text File  |  1993-06-10  |  3.0 KB  |  103 lines
  1. ;;; JACAL: Symbolic Mathematics System.        -*-scheme-*-
  2. ;;; Copyright 1992, 1993 Aubrey Jaffer.
  3. ;;; See the file "COPYING" for terms applying to this program.
  4.  
  5. ;;; The SECT: functions deal with strings which are ordered like
  6. ;;; chapters in a book.  For instance, a.9 < a.10 and 4c < 4aa.  Each
  7. ;;; section of the string consists of consecutive numeric on
  8. ;;; consecutive aphabetic characters.
  9.  
  10. ;(define (sect:string<? s1 s2)
  11. ;  (let ((l1 (string-length s1))
  12. ;    (l2 (string-length s2)))
  13. ;    (let loop ((i 0) (oc #\ ) (cmp #f))
  14. ;      (cond ((>= i l1)
  15. ;         (if (>= i l2) (and cmp (positive? cmp)) #t))
  16. ;        ((>= i l2) #f)
  17. ;        (else
  18. ;         (let ((c1 (string-ref s1 i))
  19. ;           (c2 (string-ref s2 i)))
  20. ;           (cond ((char=? c1 c2)
  21. ;              (loop (+ 1 i) c1 cmp))
  22. ;             ((or (and (char-upper-case? c1)
  23. ;                   (char-upper-case? c2))
  24. ;              (and (char-lower-case? c1)
  25. ;                   (char-lower-case? c2))
  26. ;              (and (char-numeric? c1)
  27. ;                   (char-numeric? c2)))
  28. ;              (loop (+ 1 i) c1
  29. ;                (or cmp (if (char<? c1 c2) 1 -1))))
  30. ;             ((char-upper-case? oc) (or (char-upper-case? c2)
  31. ;                        (char<? c1 c2)))
  32. ;             ((char-lower-case? oc) (or (char-lower-case? c2)
  33. ;                        (char<? c1 c2)))
  34. ;             ((char-numeric? oc) (or (char-numeric? c2)
  35. ;                         (char<? c1 c2)))
  36. ;             (else        ;Mismatched field
  37. ;              (char<? c1 c2)))))))))
  38.  
  39. (define sect:char-incr (- (char->integer #\2) (char->integer #\1)))
  40.  
  41. (define (sect:inc-string s p)
  42.   (let ((c (string-ref s p)))
  43.     (cond ((char=? c #\z)
  44.        (string-set! s p #\a)
  45.        (cond ((zero? p) (string-append "a" s))
  46.          ((char-lower-case? (string-ref s (+ -1 p)))
  47.           (sect:inc-string s (+ -1 p)))
  48.          (else
  49.           (string-append 
  50.            (substring s 0 p)
  51.            "a"
  52.            (substring s p (string-length s))))))
  53.       ((char=? c #\Z)
  54.        (string-set! s p #\A)
  55.        (cond ((zero? p) (string-append "A" s))
  56.          ((char-upper-case? (string-ref s (+ -1 p)))
  57.           (sect:inc-string s (+ -1 p)))
  58.          (else
  59.           (string-append 
  60.            (substring s 0 p)
  61.            "A"
  62.            (substring s p (string-length s))))))
  63.       ((char=? c #\9)
  64.        (string-set! s p #\0)
  65.        (cond ((zero? p) (string-append "1" s))
  66.          ((char-numeric? (string-ref s (+ -1 p)))
  67.           (sect:inc-string s (+ -1 p)))
  68.          (else
  69.           (string-append 
  70.            (substring s 0 p)
  71.            "1"
  72.            (substring s p (string-length s))))))
  73.       ((or (char-alphabetic? c) (char-numeric? c))
  74.        (string-set! s p (integer->char
  75.                  (+ sect:char-incr
  76.                 (char->integer (string-ref s p)))))
  77.        s)
  78.       (else (error "inc-string error" s p)))))
  79.  
  80. (define (sect:next-string s)
  81.   (do ((i (+ -1 (string-length s)) (+ -1 i)))
  82.       ((or (negative? i)
  83.        (char-numeric? (string-ref s i))
  84.        (char-alphabetic? (string-ref s i)))
  85.        (if (negative? i) (string-append s "0")
  86.        (sect:inc-string (string-copy s) i)))))
  87.  
  88. (define (ns s1) (sect:next-string s1))
  89.  
  90. (define (ts s1 s2)
  91.   (let ((s< (sect:string<? s1 s2))
  92.     (s> (sect:string<? s2 s1)))
  93.     (cond (s<
  94.        (display s1)
  95.        (display " < ")
  96.        (display s2)
  97.        (newline)))
  98.     (cond (s>
  99.        (display s1)
  100.        (display " > ")
  101.        (display s2)
  102.        (newline)))))
  103.